home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / calls < prev    next >
Encoding:
Text File  |  1992-01-26  |  15.5 KB  |  559 lines
  1. \ provide the ability to 'call' the amiga stuff...
  2.  
  3. \ usage example...
  4.  
  5. \ 1. graphics library has a call to 'set an entire area to a specified color':
  6. \
  7. \    SetRast( RastPort, pen )
  8. \
  9. \ where:
  10. \ 'RastPort' is a pointer to the rastPort you wish to use, and
  11. \ 'pen' is the pen value to fill the port to (0-255)
  12. \
  13. \ in JForth, the equivalent call would be:
  14. \
  15. \     ThePort @    23    call Graphics_lib SetRast
  16. \
  17. \ where:
  18. \
  19. \      'ThePort' is the address where you've stored the rastPort pointer.
  20. \           '23' is the pen value
  21. \         'call' invokes the call-assembler, which reads...
  22. \ 'Graphics_lib' as the name of a user variable which the application has
  23. \                placed the pointer returned by 'openLibrary' at startup.
  24. \                NOTE: the call-assembler will append '.fd' to find the
  25. \                      'function definition' file.
  26. \      'SetRast' is the name of the function within the library.
  27.  
  28. \ 'call' is an immediate word which:
  29. \ -- ASSEMBLES 'movem.l <forth regs>,-(sp)' to save all important stuff.
  30. \ -- scans for the 'library_lib' text and opens the 'fd' file.
  31. \    -- find library base offset.
  32. \    -- find name of call in file, using line position and base offset,
  33. \       calculate the function absolute offset.
  34. \    -- calculates the number of regs required, and which regs, ASSEMBLES
  35. \       the correct 'move' opcodes to load the regs from the stack.
  36. \ -- finds the 'library_lib' text in the dictionary and executes it.  It should
  37. \    return the address of a variable/user holding the pointer to the library
  38. \    (gotten when the application called 'openlibrary' at startup).  It then
  39. \    fetches and ASSEMBLES a 'move.l' opcode to a6.
  40. \ -- a JSR neg_offset(a6) is then ASSEMBLED.
  41. \ -- a 'push d0' is then ASSEMBLED to return any result.
  42. \ -- a 'movem.l (sp)+,<forth regs>' is ASSEMBLED to restore the forth
  43. \    environment.
  44.  
  45. \ -- example of assembled system call:
  46. \    NOTE: this hypothetical function requires regs (a0,d1) to be set up...
  47. \
  48. \ ,save.....   48e7 movem.l   d5-d6/a2-a6,-(rp)   save forth regs (cept tos)
  49. \              063e
  50. \ ,calc_lib..  307c move.w    #useroffset,a0
  51. \              xxxx
  52. \              d1cd add.l     up,a0  up=a5
  53. \              2f10 move.l    (a0),-(rp)          save pointer on rp
  54. \ ,args.....   xxxx move.l    (forthsp)+,d1       load regs..
  55. \              xxxx move.l    (forthsp)+,a0
  56. \ ,get_lib..   2c5f move.l    (rp)+,a6            put in the lib pointer
  57. \ ,jsr......   4eae jsr       index(a6)
  58. \              xxxx
  59. \ ,restore..   4cdf movem.l   (rp)+,d5-d6/a2-a6
  60. \              7c60
  61. \              ddfc adda.l    #xx,dsp
  62. \              0000
  63. \              xxxx
  64. \ ,pushd0....  2e00 move.l    d0,tos
  65.  
  66. \ -- t-t-t-h-h-hat's all, f-f-olks !!!!!!!!
  67.  
  68. \ support words...
  69. \
  70. \ Author: Mike Haas
  71. \ Copyright 1986 Delta Research
  72. \ MOD: PLB 8/29/88 Add CONVERT-AREGS
  73. \ MOD: PLB 9/4/88 Add RET:SR RET:VOID RET:DOUBLE AREGS>ABS
  74. \ MOD: PLB 1/16/91 Print library offset in ARGS
  75. \ 00001 plb/mdh 15-aug-91 Parser immune to comments after regs
  76. \ 00002 plb 16-aug-91 MAKE CALL>ABS do equivalent of IF>ABS
  77. \ 00003 mdh 26-jan-92 handle multiple ##bias statements, obey ##Private
  78.  
  79. variable theLIB
  80. variable theFDFILE
  81. variable theBIAS
  82. variable #args
  83. variable Padwas
  84. variable Verify-Libs
  85.  
  86. variable CONVERT-AREGS  ( automatically do >ABS if in areg )
  87. variable RETURN-VOID  ( don't return anything )
  88. variable RETURN-SR
  89. variable ##IsPublic  \ 00003
  90.  
  91. : libOpen?  ( name_field var-addr -- )  @ 0=
  92.   IF     " You must open " pad $move
  93.          dup dup 1+ swap c@ $ 1f and 2dup   pad $append
  94.          "   (use "  count pad $append
  95.          4 - pad $append
  96.          " ?)" count pad $append   pad $error
  97.   THEN   drop ;
  98.   
  99. : set_theLIB  ( -- , eats: NAME_lib )
  100.   ##IsPublic on  \ 00003
  101.   bl word  find  ( pfa flag -- )  dup   \ is it there?
  102.   IF   over >name dup c@ $ 1f and  ( pfa flag nfa cnt -- )
  103.        3 - + odd@  ( pfa flag last-4-chars-of-name -- )
  104.        $ 5f4c4942  ( "_LIB" ) =  and
  105.   THEN 0=
  106.   IF   ( not found )
  107.        " SET_THELIB: " pad $move
  108.        here count pad $append 
  109.        "  is not a Library  (expecting 'name_LIB')" count pad $append
  110.        pad $error
  111.   THEN
  112.   dup >name swap
  113.   ( -- lib_nfa lib_var )  dup theLIB !  execute
  114.   Verify-libs @  #args @ -1 > and
  115.   IF   here pad dup >r $move
  116.        over [compile] literal  \ compile name-addr
  117.        dup  [compile] literal  compile libopen?
  118.        r> here $move
  119.   THEN 2drop
  120. ;
  121.  
  122. : fd-dir   $" FD:"  ;
  123.  
  124.  
  125. : open_theFDFile  ( -- handle / FALSE , wants name at here )
  126.   ( build 'fd:NAME_lib.fd' in dos name-buffer... )
  127.   fd-dir   count >dos
  128.   here     count +dos
  129.   $" .FD"  count +dos
  130.   dosstring 2+ (fopen)
  131.   pad padwas !
  132. ;
  133.  
  134. : ##Bias?  ( lineadr linecnt -- flag )   ( 00003 )
  135. \ >newline ." bias?: " ?pause .s
  136.   dup 7 >
  137.   IF
  138.      over + 0 swap c!  ( la )
  139.      dup  " ##bias" count swap text=?  ( la flag )
  140.      IF
  141.         base @ >r   6 +  0 0 rot decimal convert  r> base !  2drop ?dup
  142.         IF
  143.            ( n )  theBIAS !  true
  144.         ELSE
  145.            false
  146.         THEN
  147.      ELSE
  148.         drop  0
  149.      THEN
  150.   ELSE
  151.      2drop false
  152.   THEN
  153. \ >newline ." bias? end: " .s
  154. ;
  155.  
  156. : ##Private?  ( lineadr lcnt -- flag )  ( 00003 )
  157.   drop " ##private" count swap text=?
  158.   IF
  159.      ##IsPublic off  true
  160.   ELSE
  161.      false
  162.   THEN
  163. ;
  164.  
  165. : ##Public?   ( lineadr lcnt -- flag )  ( 00003 )
  166.   drop " ##public" count swap text=?
  167.   IF
  168.      ##IsPublic on  true
  169.   ELSE
  170.      false
  171.   THEN
  172. ;
  173.  
  174. : calcBIAS?  ( -- bias true / false )
  175. \ >newline ." calcbias: " ?pause .s
  176.   false   
  177.   BEGIN
  178.      tempfile @ tempbuff
  179.      padwas @ 256 readline  ( 0 padwas linelen -- )  dup -1 >
  180.      IF
  181.        ( 0 padwas linelen )  ##Bias?   ( 00003 )
  182.         IF
  183.            drop theBIAS @  true  true
  184.         ELSE
  185.            false
  186.         THEN
  187.      ELSE
  188.         " CALL: bias not found in "  pad $move
  189.               dosstring 1+ count pad $append  pad $error
  190.         \ 2drop true
  191.      THEN
  192.   UNTIL
  193. \ >newline ." calcbias end: " .s
  194. ;
  195.  
  196. : IsAFunction?  ( padwas cnt -- flag , returns name length if a function )
  197.   over c@ ?letter
  198.   IF
  199.        dup >r  ( save cnt )  0 -rot
  200.        over + swap
  201.        DO   i c@  ascii ( =  ?leave
  202.             1+
  203.        LOOP dup r> =
  204.        IF   drop 0
  205.        THEN
  206.   ELSE 2drop 0
  207.   THEN
  208. ;
  209.  
  210. : thisFunction?  ( here cnt padwas funnamecnt -- flag )
  211.   ##IsPublic @  ( 00003 )
  212.   IF
  213.      2 pick =
  214.      IF    text=?
  215.      ELSE  3 xdrop false
  216.      THEN
  217.   ELSE
  218.      2drop 2drop false
  219.   THEN
  220. ;
  221.  
  222. : FindFunction?  ( -- flag , adds to 'theBIAS' user variable )
  223.   bl word count  ( adr cnt -- )
  224.   BEGIN
  225.      2dup  tempfile @ tempbuff
  226.      padwas @ 256 readline    ( a c a c pad pcnt -- ) ( or -1 if eof )
  227.      dup padwas @ 1- c!
  228.      dup 0 < 0=               ( a c a c pad pcnt flag -- )
  229.      IF
  230.         2dup  isafunction?  ( a c a c pad pcnt len/0 -- ) -dup
  231.         IF
  232.            swap drop     ( a c a c pad fcnt -- )
  233.            thisfunction? ( a c flag -- )
  234.            IF
  235.               2drop true true  ( stop, leave true )
  236.            ELSE
  237.               6 theBIAS +!   false      ( doit again )
  238.            THEN
  239.         ELSE
  240.            ( -- a c a c pad pcnt )  ( 00003 )
  241.            2dup ##Bias? 0=
  242.            IF
  243.               2dup ##Public? 0=
  244.               IF
  245.                  2dup ##Private? drop
  246.               THEN
  247.            THEN
  248.            2drop 2drop  false      ( doit again )
  249.         THEN
  250.      ELSE
  251.         2drop 2drop 2drop false true   ( stop, leave false )
  252.      THEN
  253.   UNTIL
  254. ;
  255.  
  256. : register?  ( adr -- flag , proper register notation? )
  257.   dup c@  $ 20 or  dup ascii a = swap ascii d =  or
  258.   swap  1+ c@  ascii 0  ascii 7 within? and
  259. ;
  260.  
  261. \ 00002
  262. : CONVERT.AREGS.TST ( reg# type -- , convert areg params to absolute )
  263.   IF ( address register )
  264.      convert-aregs @
  265.      IF ( reg# )
  266.          4 = IF
  267.            " CALL: Can't use AREGS>ABS when A4 passes a parameter!" $error
  268.          THEN
  269.          $ 4A96 w, \ tst.l  (dsp)
  270.      ELSE drop
  271.      THEN
  272.   ELSE drop
  273.   THEN
  274. ;
  275.  
  276. : CONVERT.AREGS.ADD ( reg# type -- , convert areg params to absolute )
  277.   IF ( address register )
  278.      convert-aregs @
  279.      IF ( reg# )
  280.         $ 6702 w,     \ BNE  past adda.l
  281.          7 and 9 shift $ D1CC or w,   \ adda.l org,ar
  282.      ELSE drop
  283.      THEN
  284.   ELSE drop
  285.   THEN
  286. ;
  287.  
  288. : xr!   ( reg# type -- )
  289.   2dup convert.aregs.tst \ 00002
  290.   2dup
  291.   6 shift  $ 40 and  swap  ( type reg# -- )
  292.   9 shift or   $ 201e or   ( opcode assembled )  ( move.l  <sp>+,?? )
  293.   w,
  294.   convert.aregs.add
  295. ;
  296.  
  297. \ : dr!   ( data reg# -- )
  298. \   0 xr!
  299. \ ; immediate
  300.  
  301. \ : ar!   ( data reg# -- )
  302. \   1 xr!
  303. \ ; immediate
  304.  
  305. \ ,args.....   xxxx move.l    (forthsp)+,d1       load regs..
  306.  
  307. : ,args  ( -- , fd text/cnt at pad-1 )
  308.   padwas @ 1- count   ( -- pad cnt )
  309.   ascii ) scan ( -- addr' count' , 00001 )
  310.   dup 0= abort" ,ARGS - bad .fd file!"
  311.   1- swap 1+ swap ( move past that paren )
  312.   ascii ) scan ( -- addr'' count'' )
  313.   drop \ find second ')' just past args , ignores comments past regs
  314.   2-  ( points to last reg text )
  315.   0 swap ( #args adr -- )
  316.   BEGIN  ( #args adr -- )  dup register?
  317.   WHILE  dup 1+ c@ $ 0f and   ( gets register #)   ( #args adr reg# -- )
  318.          over c@  $ 20 or   ascii a =
  319.          ( #args adr reg# type -- )
  320.          [compile] xr!  ( #args adr -- )  3 -
  321.          swap 1+ swap
  322.   REPEAT drop    #args !
  323. ;  
  324.  
  325. \ ,dropargs  add.l #args*4,dsp 
  326. : ,dropargs ( -- , asm code to add to dsp )
  327.   #args @ -dup
  328.   IF    cells        \ amt on stack
  329.         $ ddfc  w,   \ adda.l  #??,dsp   dsp=a6
  330.         ,            \ the amount to add
  331.   THEN  ;
  332.  
  333. : ,sp    ( -- , put in code to save proper stack value with args gone )
  334.   $ 2f0e w,         ;
  335.  
  336. \ ,save.....   48e7 movem.l   d5-d6/a3-a6,-(rp)   save forth regs (cept tos)
  337. \              061e
  338. : ,save  ( -- , put in the movem.l instruction )
  339.   $ 48e7,063e ,   ;  ( movem.l   d5-d6,a2-a6 )
  340.  
  341. \ 'calc_lib..  ???? jsr      lib-var
  342. \              xxxx
  343. \              2f34 move.l   0(org,tos.l),-(rp)
  344. \              7800
  345. \              2e1e move.l   (dsp)+,tos
  346. : ,calc_lib  ( -- , asm code to get lib pointer )
  347.   theLIB @ cfa,  $ 2f34,7800 ,  $ 2e1e w,  ;
  348.  
  349. \ ,get_lib..   2c5f move.l    (rp)+,a6            put in the lib pointer
  350. : ,get_lib  ( -- , asm code to load user addr holding lib pointer )
  351.   $ 2c5f w,  ;
  352.  
  353. : ,jsr  ( -- , asm code to do the call )
  354.   $ 4eae w,  theBIAS @ negate w,   ;
  355.  
  356. : ,!sp  ( -- asm code to restore stack )
  357.   $ 2c5f w,          ;
  358.  
  359. \ ,restore..   4cdf movem.l   (rp)+,d5-d6/a2-a6
  360. \              7c60
  361. : ,restore  ( -- , asm code to restore forth regs )
  362.   $ 4cdf,7c60 ,    ;
  363.  
  364. : ,dummypush  ( -- , get all items on the stack )
  365.   $ 2d07    w,     ;
  366.  
  367. : ,pushd0  ( -- , asm code to push the result on the stack )
  368.   $ 2e00    w,     ;
  369.  
  370. : ,MOVESR,D2 ( -- , move sr,d2 )
  371.   $ 48E7 w, $ 8000 w, \ movem.l d0,-(rp)          
  372.   $ 2078 w, $ 0004 w, \ move.l  $-2803D4,a0       
  373.   $ 4EA8 w, $ FDF0 w, \ jsr     $-210(a0)         
  374.   $ 2400 w,         \ move.l  d0,d2             
  375.   $ 201F w,         \ move.l  (rp)+,d0          
  376. ;
  377.  
  378. : ,PUSHD2 ( -- , push d2 to tos to return SR )
  379.     $ 2d07 w, $ 2e02 w, ;
  380.  
  381. USER PUSHD1
  382. : ,PUSHD0/D1  $ 2D00 W, $ 2E01 W, ;
  383.  
  384. : <call>  ( -- , eats: <NAME_lib>  <function_name>  )  #args off
  385.   ?comp set_theLIB             ( -- )
  386.   open_theFDFile -dup
  387.   IF   ( the file opened ok )
  388.        dup tempfile !    ( fh -- ) \ save the filehandle
  389.        markfclose        ( -- )    \ mark it for auto-closing by quit...
  390.        tempbuff openfv   ( adr-- ) \ I need a new area!
  391.        markfreeblock
  392.        calcBIAS?         ( bias true / false -- )
  393.        2drop    ( 00003 )
  394.        \ IF-NOT ( 00003 )
  395.        \    cr ." CALL: no BIAS found in " dosstring 1+ count type 0sp quit
  396.        \ THEN
  397.        \ theBIAS !
  398.        FindFunction?     ( flag -- )
  399.        IF   ( name found AND theBIAS recalculated... )
  400.             ,dummypush
  401.             ,save       ( -- )    \ asm the 'save-state' opcode...
  402.             ,calc_lib
  403.             ,args       ( -- )    \ asm the args loading codes...
  404.             ,get_lib    ( -- )    \ asm code to load lib ptr in a6...
  405.             ,jsr        ( -- )    \ asm the actual jsr...
  406.             ,restore    ( -- )    \ asm the 'restore-state' opcode...
  407.             return-sr @
  408.             IF ,movesr,d2
  409.             THEN
  410.             ,dropargs
  411.             return-void @
  412.             IF compile drop  ( no return value )
  413.             ELSE PUSHD1 @ 
  414.               IF   ,pushd0/d1    \ For double number returns: MATHIEEEDOUBBAS
  415.               ELSE ,pushd0     ( -- )    \ asm code to push any result...
  416.               THEN
  417.             THEN
  418.             return-sr @
  419.             IF ,pushd2
  420.             THEN
  421.        ELSE
  422.             " CALL: " pad $move
  423.             here count pad $append
  424.             " () not found in " count pad $append
  425.             dosstring 1+ count pad $append
  426.             pad $error
  427.        THEN
  428.        tempbuff @ unmarkfreeblock
  429.        tempbuff closefvread
  430.        tempfile @ dup unmarkfclose fclose
  431.   ELSE
  432.        " CALL: " pad $move
  433.        dosstring 1+ count pad $append
  434.        "  not found."  count pad $append
  435.        pad $error
  436.   THEN
  437.   convert-aregs off
  438.   return-void off
  439.   return-sr off
  440.   pushd1 off
  441. ; 
  442.  
  443. : CALL    ( -- , eats: <NAME_lib>  <function_name>  )  ( returns 32 bit d0)
  444.   PUSHD1 OFF <CALL> ; IMMEDIATE
  445.  
  446. \ Words for combining calling options.
  447. : RET:VOID ( -- ) return-void on  pushd1 off ; IMMEDIATE
  448. : RET:DOUBLE ( -- ) pushd1 on return-void off ; IMMEDIATE
  449. : RET:SR ( -- ) return-sr on ; IMMEDIATE
  450. : AREGS>ABS ( -- ) convert-aregs on ; IMMEDIATE
  451.  
  452. : DCALL   ( -- , eats: <NAME_lib>  <function_name>  )  ( returns d0/d1 )
  453.   PUSHD1 ON  <CALL> ; IMMEDIATE
  454.  
  455. : CALL>ABS  (  <NAME_lib>  <function_name> --  ) ( returns 32 bit d0)
  456. \ Convert any parameters in address registers to absolute.
  457.   convert-aregs ON  <CALL>
  458. ; IMMEDIATE
  459.  
  460. : CALLVOID  (  <NAME_lib>  <function_name> --  ) ( returns nothing)
  461.   return-void ON  <CALL>
  462. ; IMMEDIATE
  463.  
  464. : CALLVOID>ABS  (  <NAME_lib>  <function_name> --  ) ( returns nothing)
  465.   return-void ON  convert-aregs ON <CALL>
  466. ; IMMEDIATE
  467.  
  468. turnkeying? NOT .IF
  469. : args  ( -- , eats: <NAME_lib>  <function_name>  )  -1 #args !
  470.   set_thelib
  471.   open_theFDFile -dup
  472.   IF   ( the file opened ok )
  473.        dup tempfile !    ( fh -- ) \ save the filehandle
  474.        markfclose        ( -- )    \ mark it for auto-closing by quit...
  475.        tempbuff openfv   ( adr-- ) \ I need a new area!
  476.        markfreeblock
  477.        calcBIAS?
  478.        IF   theBIAS !
  479.        ELSE 0 theBIAS !
  480.        THEN
  481.        FindFunction?     ( flag -- )
  482.        IF   ( name found ... )cr cr
  483.             padwas @ 1- count type
  484.             ."  $-" theBIAS @ .hex cr cr
  485.        ELSE
  486.             cr ." ARGS: " here count type
  487.             ." () not found in " dosstring 1+ count type  0sp quit
  488.        THEN
  489.        tempbuff @ unmarkfreeblock
  490.        tempbuff closefvread
  491.        tempfile @ dup unmarkfclose fclose
  492.   ELSE
  493.        cr ." ARGS: " dosstring 1+ count type ."  not found" 0sp quit
  494.   THEN
  495. ; immediate
  496. .THEN
  497.  
  498. 1 .if
  499.  
  500. include jf:LibDefs
  501.  
  502. .then
  503.  
  504. : LOCK()   ( 0name accessmode -- lock OR 0 if fail )
  505.   swap  >abs  swap    call dos_lib Lock
  506. ;
  507.  
  508. : $LOCK()  ( &forth-string access-mode -- lock or 0 , NOT converted via >rel )
  509.   swap count >dos dos0 swap Lock()
  510. ;
  511.  
  512. : MyDir  ( -- lock on current directory )
  513.   TASKBASE @ >rel    ( ..@ pr_CurrentDir )  $ 98 + @
  514. ;
  515.  
  516. : UNLOCK()  ( lock -- , always handled in ABS form, just as received )
  517.   \ UnLock IF:
  518.   \ It's not equal to my CurrentDir              AND
  519.   \ It's not equal to the original CLI lock      AND
  520.   \ It's not equal to the original WB lock....
  521.   dup MyDir -
  522.   IF
  523.      dup WBMESSAGE @  \ 00001
  524.      IF
  525.         wbLOCK
  526.      ELSE
  527.         cliLOCK
  528.      THEN
  529.      @ -
  530.      IF
  531.         call dos_lib UnLock
  532.      THEN
  533.   THEN
  534.   drop
  535. ;
  536.  
  537. : CURRENTDIR()  ( lock -- prevlock )
  538.   call dos_lib CurrentDir
  539. ;
  540.  
  541. : cd    ( -- , eats name from input )
  542.   fileword ACCESS_READ $Lock()  -dup
  543.   IF     CurrentDir()  ( -- prevlock )  UnLock()
  544.   ELSE   .err dosstring 1+ $type ."  not found" quit
  545.   THEN   ;
  546.  
  547. : (?TERMINAL.DELAY) ( micros -- flag )
  548.     consolein @ dup
  549.     IF
  550.         swap 1 max
  551.         call dos_lib WaitForChar
  552.     ELSE
  553.         nip
  554.     THEN
  555. ;
  556.  
  557. defer ?TERMINAL.DELAY  ' (?TERMINAL.DELAY) is ?TERMINAL.DELAY
  558.  
  559.